home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / sparcsuspend.t < prev    next >
Encoding:
Text File  |  1989-07-20  |  9.3 KB  |  258 lines
  1. (herald sparcsuspend (env tsys (link suspend)))
  2.  
  3. (lset pure-size nil)
  4.  
  5. (define (set-up-the-slink)
  6.   (modify (+area-frontier (lstate-impure *lstate*))
  7.           (lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
  8.   (let ((null 
  9.          (object nil
  10.            ((heap-stored self) (lstate-impure *lstate*))
  11.            ((heap-offset self) (fx+ %%stack-size tag/pair))
  12.            ((write-descriptor self stream)
  13.             (write-data stream (fx+ %%stack-size tag/pair)))
  14.            ((write-store self stream)
  15.         (do ((i 0 (fx+ i 4)))
  16.         ((fx= i %%stack-size))
  17.           (write-int stream 0))
  18.             (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  19.               (do ((i 0 (fx+ i 4)))
  20.                   ((fx= i pi)
  21.                    (write-int stream 0)
  22.                    (write-int stream (+area-frontier (lstate-pure *lstate*)))
  23.                    (write-data stream %%stack-size)
  24.                    (write-data stream (+area-frontier (lstate-impure *lstate*)))
  25.                    (write-int stream (fx-ashl (fx+ (gc-stamp) 1) 2))
  26.                    (do ((i (fx+ i 20) (fx+ i 4)))
  27.                        ((fx= i %%slink-size))
  28.                      (write-int stream 0)))
  29.                 (write-int stream 0)))))))
  30.     (set (lstate-null *lstate*) null)
  31.     (push (+area-objects (lstate-impure *lstate*)) null)
  32.   (reloc-thunk (object nil
  33.          ((heap-stored self) (lstate-pure *lstate*))
  34.          ((write-descriptor self stream)
  35.           (write-int stream 0)))
  36.            (fx+ %%stack-size
  37.             (fx+ slink/initial-pure-memory-begin 3)))
  38.   (reloc-thunk (object nil
  39.          ((heap-stored self) (lstate-pure *lstate*))
  40.          ((write-descriptor self stream)
  41.           (write-int stream (+area-frontier (lstate-pure *lstate*)))))
  42.            (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
  43.   (reloc-thunk (object nil
  44.          ((heap-stored self) (lstate-impure *lstate*))
  45.          ((write-descriptor self stream)
  46.           (write-data stream %%stack-size)))
  47.            (fx+ %%stack-size
  48.             (fx+ slink/initial-impure-memory-begin 3)))
  49.   (reloc-thunk (object nil
  50.          ((heap-stored self) (lstate-impure *lstate*))
  51.          ((write-descriptor self stream)
  52.           (write-data stream (+area-frontier (lstate-impure *lstate*)))))
  53.            (fx+ %%stack-size
  54.             (fx+ slink/initial-impure-memory-end 3)))
  55.     null))
  56.  
  57.  
  58. ;;; Look at a Unix a.out description and template.doc
  59.  
  60. (define (suspend obj out-spec x?)
  61.   (set (experimental?) x?)
  62.   (really-suspend obj out-spec 'o))
  63.  
  64. (define-constant RELOC-SIZE 12)
  65. (define-constant CYMBAL-SIZE 12)
  66. (define-constant OMAGIC #o407)
  67. (define-constant N_TEXT 4)
  68. (define-constant N_DATA 6)
  69. (define-constant N_UNDF 0)
  70. (define-constant N_EXT 1)
  71.  
  72. (define (vgc-foreign foreign)
  73.   (let* ((heap (lstate-impure *lstate*))
  74.          (addr (+area-frontier heap))
  75.          (name (foreign-name foreign))
  76.          (desc (object nil
  77.                  ((heap-stored self) (lstate-impure *lstate*))
  78.                  ((heap-offset self) addr)
  79.                  ((write-descriptor self stream)
  80.                   (write-data stream (fx+ addr tag/extend)))
  81.                  ((write-store self stream)
  82.                   (write-int stream header/foreign)
  83.                   (write-slot name stream)
  84.                   (write-int stream 0)))))
  85.     (set (+area-frontier heap) (fx+ addr 12))
  86.     (push (+area-objects heap) desc)
  87.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  88.     (generate-slot-relocation name (fx+ addr 4))
  89.     (cymbal-thunk (string-append "_" (symbol->string name))
  90.      (fixnum-logior N_UNDF N_EXT) 0)
  91.     (reloc-thunk (fixnum-logior (fixnum-ashl (lstate-symbol-count *lstate*) 8)
  92.                                 #x82)
  93.                  (fx+ addr 8))
  94.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  95.     desc))
  96.  
  97. (define (generate-slot-relocation obj slot-address)
  98.   (cond ((or (fixnum? obj) (immediate? obj)))
  99.     (else
  100.      (reloc-thunk (vgc obj) slot-address))))
  101.             
  102.  
  103. (define (reloc-thunk type address)
  104.   (push (lstate-data-reloc *lstate*)
  105.         (cons address type)))
  106.  
  107.  
  108. (define (write-slot obj stream)
  109.   (cond ((fixnum? obj)
  110.          (write-fixnum stream obj))
  111.         ((immediate? obj)
  112.          (write-immediate stream obj))
  113.         ((null? obj)
  114.          (write-descriptor (lstate-null *lstate*) stream))
  115.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  116.          => (lambda (desc) (write-descriptor desc stream)))
  117.         (else
  118.          (write-descriptor (lstate-null *lstate*) stream))))
  119.  
  120. (define-integrable (write-int stream int)
  121.   (write-half stream (fixnum-ashr int 16))
  122.   (write-half stream int))
  123.                        
  124. (define-integrable (write-immediate stream imm)
  125.   (let ((int (descriptor->fixnum imm)))
  126.     (write-half stream (fixnum-ashr int 14))
  127.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  128.                                                      
  129. (define-integrable (write-scratch stream obj i)
  130.   (let ((offset (fixnum-ashl i 2)))
  131.     (write-half stream (mref-16-u obj offset))
  132.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  133.     
  134. (define-integrable (write-half stream int)
  135.   (vm-write-byte stream (fixnum-ashr int 8))
  136.   (vm-write-byte stream int))
  137.  
  138. ;(define-integrable (write-byte stream n)
  139. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  140.  
  141. (define-integrable (write-fixnum stream fixnum)
  142.   (write-half stream (fixnum-ashr fixnum 14))
  143.   (write-half stream (fixnum-ashl fixnum 2)))
  144.  
  145.  
  146. (define (cymbal-thunk stryng type value)
  147.  (push (lstate-symbols *lstate*)
  148.   (object (lambda (stream a)
  149.             ;; a is offset into stryng table
  150.             (write-int stream a)
  151.             (vm-write-byte stream type)
  152.             (vm-write-byte stream 0)       ; other
  153.             (write-half stream 0)       ; see <stab.h>                 
  154.             (if (fixnum? value)            ; undefined external (foreign)
  155.                 (write-int stream 0)
  156.                 (write-descriptor value stream)))
  157.           ((cymbal-thunk.stryng self) stryng))))
  158.  
  159.  
  160. (define-operation (cymbal-thunk.stryng thunk))
  161.  
  162. (define-integrable (write-data stream int)
  163.   (write-int stream (fx+ pure-size int)))
  164.  
  165. (define (make-global-cymbal proc name)
  166.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  167.        => (lambda (desc)                                
  168.             (cymbal-thunk (string-downcase! (symbol->string name))
  169.                           (fixnum-logior N_DATA N_EXT)
  170.                           desc)
  171.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  172.            
  173.       (else
  174.        (error "~s not defined" name))))
  175.  
  176.                                        
  177. (define (write-link-file stream)
  178.   (make-global-cymbal big_bang 'big_bang)
  179.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  180.   (pad-area (lstate-pure *lstate*))
  181.   (pad-area (lstate-impure *lstate*))
  182.   (set pure-size (+area-frontier (lstate-pure *lstate*)))
  183.   (write-header     stream)
  184.   (write-area       stream (lstate-pure *lstate*))
  185.   (write-area       stream (lstate-impure *lstate*))
  186.   (write-relocation stream (lstate-data-reloc *lstate*))  
  187.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  188.  
  189. (define (write-header stream)
  190.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  191.          (data-size (+area-frontier (lstate-impure *lstate*))))
  192.     (write-half stream #x0103)                     ; only on sparc
  193.     (write-half stream OMAGIC)                ;magic number
  194.     (write-int stream text-size)              ;text segment size
  195.     (write-int stream data-size)              ;data segment size
  196.     (write-int stream 0)                      ;bss  segment size
  197.     (write-int stream (fx* CYMBAL-SIZE (lstate-symbol-count *lstate*)))
  198.     (write-int stream 0)                      ;bogus entry point
  199.     (write-int stream 0)                      ; no text relocation
  200.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))))
  201.  
  202. (define (write-area stream area)
  203.   (walk (lambda (x) (write-store x stream))
  204.         (reverse! (+area-objects area))))
  205.  
  206.  
  207.  
  208. (define (write-relocation stream items)
  209.   (walk (lambda (item)
  210.       (let ((addr (car item))
  211.         (desc (cdr item)))
  212.           (write-int stream (car item))
  213.       (cond ((fixnum? desc)
  214.          (write-int stream desc)
  215.          (write-int stream 0))
  216.         ((eq? (heap-stored desc) (lstate-pure *lstate*))
  217.          (write-int stream #x402)
  218.          (write-descriptor desc stream))
  219.         (else
  220.          (write-int stream #x602)
  221.          (write-descriptor desc stream)))))         
  222.         (sort-list! items
  223.                     (lambda (x y)      
  224.                        (fx< (car x) (car y))))))
  225.           
  226.  
  227.           
  228.                              
  229. (define (write-cymbal&stryng-table stream cyms)
  230.   (let ((z (write-cyms stream cyms))) ; cymbal table
  231.     (write-int stream z)       ; size of stryng table
  232.     (walk (lambda (s)             ; write stryng table
  233.             (write-string stream (cymbal-thunk.stryng s))
  234.             (vm-write-byte stream 0))
  235.            cyms)))
  236.  
  237. (define (write-cyms stream cyms)
  238.   (iterate loop ((a 4)                      ;; 4 bytes for size of stryng table
  239.                  (l cyms))
  240.     (cond ((null? l) a)
  241.           (else
  242.            (let ((e (car l)))
  243.              (e stream a)
  244.              (loop (fx+ (fx+ a (string-length (cymbal-thunk.stryng e))) 1) ;null
  245.                    (cdr l)))))))
  246.  
  247.  
  248. (define (pad-area area)
  249.   (let ((rem (fixnum-remainder (+area-frontier area) 16)))
  250.     (cond ((fxn= rem 0)
  251.        (modify (+area-frontier area)
  252.            (lambda (x) (fx+ x (fx- 16 rem))))
  253.        (do ((i (fx- 16 rem) (fx- i 4)))
  254.            ((fx= i 0))
  255.          (push (+area-objects area)
  256.            (object nil
  257.              ((write-store self stream)
  258.               (write-int stream 0)))))))))